home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Janim / tests / make_abr.f next >
Encoding:
FORTH Source  |  1992-01-28  |  4.3 KB  |  229 lines
  1. \ Make an ANIMBRUSH from a single picture.
  2. \
  3. \ Author: Phil Burk
  4. \ Copyright 1991 Phil Burk
  5. \
  6. \ 00001 PLB 1/28/92 Use multiples of 16 for ANIMBRUSHES
  7.  
  8. include? choose ju:random
  9. include? picture jiff:load_pic
  10. include? anim janim:load_anim
  11.  
  12. ANEW TASK-MAKE_ABR
  13.  
  14. \ Declare structures needed
  15. picture tiled-pic
  16. picture pic0
  17. picture pic1
  18. animbrush newabr
  19. 0 value MAB_DX
  20. 0 value MAB_DY
  21. 3 value MAB_NX
  22. 2 value MAB_NY
  23. mab_nx mab_ny * value MAB_NCELS
  24.  
  25. create $MAB-INFILE 64 allot
  26. create $MAB-OUTFILE 64 allot
  27.  
  28. : MAB.TERM
  29.     newabr abr.free
  30.     tiled-pic pic.free
  31.     pic0 pic.free
  32.     pic1 pic.free
  33. ;
  34. if.forgotten mab.term
  35.  
  36. : PIC.CALC.TILEXY { nx ny pict | pw ph dx dy --> dx dy }
  37. \ calculate X and Y values for subpictures
  38.     pict pic.get.wh -> ph -> pw
  39.     pw nx / \ calc dx
  40.     16 / 16 * \ adjust to multiple of 16 for Bitmaps 00001
  41.     -> dx
  42. \
  43.     ph ny / -> dy
  44. \ autoreturn locals
  45. ;
  46.  
  47. : MAB.CALC.XY ( N -- x y , set X,Y in tiled pic )
  48.     mab_nx /mod ( -- col row )
  49.     swap mab_dx *
  50.     swap mab_dy * 
  51. ;
  52.  
  53. : MAB.GET.NTH { N pict -- , put in small-pic }
  54.     N mab.calc.xy tiled-pic pic.put.xy
  55.     pict pic.drawto
  56.     0 0 tiled-pic pic.blit
  57. ;
  58.  
  59. : GR.RECT.XYWH { x0 y0 w h -- }
  60.     x0 y0
  61.     x0 w 1- 1 max + \ 10 wide goes from 10 to 19, not 10 to 20, so 1-
  62.     y0 h 1- 1 max +
  63.     gr.rect
  64. ;
  65.  
  66. : MAB.CLEAR.NTH ( N -- clear X,Y in tiled pic )
  67.     tiled-pic pic.drawto
  68. \
  69.     gr.color@ >r \ save old color
  70.     0 gr.color!
  71.     mab.calc.xy ( x0 y0 )
  72.     tiled-pic pic.get.wh ( x0 y0 w h )
  73.     gr.rect.xywh
  74.     r> gr.color!
  75. ;
  76.     
  77. : MAB.MAKE.ABR  ( -- error? , make an ANIMBRUSH from tiles )
  78. \ build initial animbrush
  79.     0 pic0 mab.get.nth
  80.     1 pic1 mab.get.nth
  81.     pic0 pic1 newabr abr.build? ?goto.error
  82.     0 mab.clear.nth
  83.     1 mab.clear.nth
  84. \
  85. \ draw fake close gadget
  86.     1 gr.color!
  87.     0 0 10 10 gr.rect
  88.     0 gr.color!
  89.     4 4 6 6 gr.rect
  90.     1 gr.color!
  91. \
  92. \ append the remaining pictures
  93.     mab_nx mab_ny *
  94.     mab_ncels MIN    2
  95.     DO
  96.         i pic0 mab.get.nth
  97.         pic0 newabr abr.append.cel? ?goto.error
  98.         i mab.clear.nth
  99.     LOOP
  100.     tiled-pic pic.drawto
  101. \
  102.     false
  103.     exit
  104. ERROR:
  105.     newabr abr.free
  106.     true
  107. ;
  108.  
  109. : GET.NEXT.PARAM ( <optional_param> -- N TRUE | FALSE )
  110.     bl word dup c@ 0>
  111.     IF
  112.         dup number?
  113.         IF drop nip TRUE
  114.         ELSE ." Bad parameter = " count type cr FALSE
  115.         THEN
  116.     ELSE
  117.         drop FALSE
  118.     THEN
  119. ;
  120.  
  121. : MAB.HELP ( -- , give help )
  122.     cr
  123.     ." Convert a tiled picture to an ANIMBRUSH!" cr
  124.     ." Usage:   MAB infile outfile {nx} {ny} {ncels}" cr
  125.     ."    infile  = an ILBM picture file name" cr
  126.     ."    outfile = a new ANIMBRUSH file name" cr
  127.     ."    nx    = number of X columns (optional, default = 3)" cr
  128.     ."    ny    = number of Y rows    (optional, default = 2)" cr
  129.     ."    ncels = number of cels      (optional, default = NX*NY)" cr
  130. ;
  131.  
  132. : MAB.GET.PARAMS ( <infile> <outfile> {nx} {ny} {ncels} -- error? )
  133.     >newline
  134.     ." MAB - by Phil Burk, Version 1.0, written in JForth" cr
  135. \ get filenames
  136.     fileword dup c@ 62 <
  137.     IF  $mab-infile $move
  138.     ELSE ." Input Filename too long, > 62 chars" cr
  139.         count type cr
  140.     THEN
  141. \
  142.     fileword dup c@ 62 <
  143.     IF  $mab-outfile $move
  144.     ELSE ." Output Filename too long, > 62 chars" cr
  145.         count type cr
  146.     THEN
  147. \
  148. \ get optional values from command line
  149.     get.next.param
  150.     IF
  151.         dup 1 32 within?
  152.         IF -> mab_nx
  153.         ELSE drop ." 1 <= NX <= 32" cr goto.error
  154.         THEN
  155.     THEN
  156.     get.next.param
  157.     IF
  158.         dup 1 32 within?
  159.         IF -> mab_ny
  160.         ELSE drop ." 1 <= NY <= 32" cr goto.error
  161.         THEN
  162.     THEN
  163.     get.next.param
  164.     IF
  165.         1 max -> mab_ncels
  166.     ELSE
  167.         mab_nx mab_ny * -> mab_ncels \ set default
  168.     THEN
  169.     false exit
  170.     ERROR:
  171.     mab.help
  172.     true
  173. ;
  174.  
  175. : MAB.INIT ( -- error? )
  176.     $mab-infile tiled-pic $pic.load? ?goto.error
  177.     mab_nx mab_ny tiled-pic pic.calc.tilexy
  178.     -> mab_dy -> mab_dx
  179.     mab_dx mab_dy tiled-pic pic.put.wh  \ set window into large picture
  180. \
  181. \ make small pictures for parts
  182.     0 0 tiled-pic pic.get.depth
  183.     mab_dx mab_dy pic0 pic.make? ?goto.error
  184. \
  185.     0 0 tiled-pic pic.get.depth
  186.     mab_dx mab_dy pic1 pic.make? ?goto.error
  187. \
  188.     false
  189.     exit
  190. ERROR:
  191.     mab.help
  192.     true
  193. ;
  194.  
  195. : MAB.STATS ( -- , report statistics )
  196.     ." Tiled picture = "
  197.     tiled-pic dup pic.whole pic.get.wh
  198.     swap . ."  by " . cr
  199. \
  200.     ." Each CEL = " mab_dx . ."  by " mab_dy . cr
  201. \
  202.     newabr abr.stats
  203. ;
  204.  
  205. : MAB ( <infile> <outfile> {nx} {ny} {ncels} -- )
  206.     gr.init
  207.     mab.get.params ?goto.error
  208.     mab.init ?goto.error
  209.     mab.make.abr ?goto.error
  210. \
  211. \ show new animbrush
  212.     BEGIN
  213.         20 30 newabr abr.blit
  214.         newabr abr.advance
  215.         20 wait.frames
  216.         ?terminal ?closebox OR
  217.     UNTIL
  218. \
  219. \ save it to disk
  220.     $mab-outfile newabr $abr.save? ?goto.error
  221.     mab.stats
  222. \
  223. ERROR:
  224.     mab.term
  225.     gr.term
  226. ;
  227.  
  228. cr ." Enter:  MAB <infile> <outfile> {nx} {ny} {ncels}" cr
  229.